home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / jx4nt123.zip / UTILS / UTILS.UTF (.txt) < prev    next >
Null Bytes Alternating  |  1994-08-26  |  10KB  |  183 lines
  1. \ utils.utf .. basic utilities for Jax4th
  2. \ Copyright (c)1994 Jack J. Woehr
  3. \ P.O. Box 51, Golden, Colorado 80402-0051
  4. \ jax@well.sf.ca.us 72203.1320@compuserve.com
  5. \ SYSOP RCFB (303) 278-0364 2400/9600/14400
  6. \ All Rights Reserved
  7. \ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  8. \ This is free software and can be modified and redistributed under
  9. \ certain conditions described in the file COPYING.TXT. The
  10. \ Disclaimer of Warranty and License for this free software are also
  11. \ contained in the file COPYING.TXT.
  12. \ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  13.  
  14. \
  15. \ $Log: utils.f,v $
  16. \ Revision 1.4  1994/08/26  15:30:43  jax
  17. \ Fixed VOCABULARY.
  18. \
  19. \
  20.  
  21. \ Standard information:
  22. \ A lot of the code in this file is very implementation dependent.
  23. \
  24.  
  25. MARKER utils.utf
  26.  
  27. \ ~~~~~~~~~~~~~~~~~
  28. \ General utilities
  29. \ ~~~~~~~~~~~~~~~~~
  30.  
  31. DECIMAL
  32.  
  33. \ This is from the Toolkit wordset.
  34. : .( [CHAR] ) PARSE TYPE ; IMMEDIATE
  35.  
  36. CR .( Loading Utilities) CR
  37.  
  38. \ Usage: INCLUDE path\path\filename.utf
  39. : INCLUDE ( "ccc<>" -- ) BL WORD COUNT INCLUDED ;
  40.  
  41. \ The next two are from Forth history.
  42. : DEFER CREATE ['] NOOP DOES> @ EXECUTE ;
  43.  
  44. \ Works on DEFER words.
  45. : IS ( xt "name" <interp> | "name" <compiling> --)
  46.   ' >BODY
  47.   STATE @
  48.   IF POSTPONE LITERAL POSTPONE !
  49.   ELSE !
  50.   THEN   ; IMMEDIATE
  51.  
  52. \ double constant
  53. : DCONSTANT ( Compile: d|ud name --  Name Execute: -- d|ud)
  54.    CREATE , , DOES> 2@ ;
  55.  
  56. \ cell array
  57. : ARRAY ( n --)
  58.    CREATE CELLS ALLOT
  59.    DOES> ( n - i) SWAP CELLS + ;
  60.  
  61. \ Type a possibly null-terminated string
  62. : 0TYPE ( c-addr u --)
  63.     0
  64.     ?DO
  65.         DUP I CHARS +   \ -- c-addr c-addr'
  66.         C@ ?DUP         \ -- c-addr char char|--
  67.         IF              \ -- c-addr char
  68.             EMIT        \ -- c-addr
  69.         ELSE            \ -- c-addr
  70.             LEAVE       \ -- c-addr
  71.         THEN
  72.     LOOP DROP           \ --
  73. ;
  74.  
  75. \ ~~~~~~~~~~~~~~~~~~~~~~~~
  76. \ BLOCK loading extensions
  77. \ ~~~~~~~~~~~~~~~~~~~~~~~~
  78.  
  79. \ Load relative to current contents of BLK
  80. : +LOAD ( n --) BLK @ + LOAD ;                        
  81. : +THRU ( n1 n2 --) BLK @ TUCK + >R + R> THRU ;
  82.  
  83. \ ~~~~~~~~~~~~
  84. \ Search order
  85. \ ~~~~~~~~~~~~
  86.  
  87. \ Set a reasonable order.
  88. : USEFUL ( --)                                        
  89.     SYSTEM-WORDLIST NONSTANDARD-WORDLIST FORTH-WORDLIST
  90.     3 SET-ORDER DEFINITIONS ;
  91.  
  92. \ Analogous to ALSO but takes a wordlist identifier argument.
  93. : ALSO-WID ( wid --)
  94.     >R GET-ORDER R> SWAP 1+ SET-ORDER ;                
  95.  
  96. \ Set the order to include all the Jax4th system wordlists.
  97. : ALL ( --) USEFUL INTERNALS-WORDLIST ALSO-WID ;
  98.     
  99.  
  100. \ ~~~~~~~~~~~~~~~~~~~
  101. \ Some Error Handling
  102. \ ~~~~~~~~~~~~~~~~~~~
  103.  
  104. DECIMAL
  105.  
  106. \ Stick these error codes in the Nonstandard wordlist.
  107. USEFUL NONSTANDARD-WORDLIST SET-CURRENT
  108.  
  109. -03 CONSTANT stack_under_throw
  110. -37 CONSTANT file_io_throw
  111. -50 CONSTANT search_order_underflow_throw
  112. -256 CONSTANT sys_throw_0
  113. -300 CONSTANT invalid_xt
  114.  
  115. \ check for sufficient args
  116. : ?ENOUGH ( i*j n -- i*j | throw)
  117.    DEPTH 1- > stack_under_throw AND THROW ;
  118.  
  119. \ ~~~~~~~~~~~~~~~~~~
  120. \ Named vocabularies
  121. \ ~~~~~~~~~~~~~~~~~~
  122.  
  123. USEFUL
  124.  
  125. : SET-CONTEXT ( wid --)
  126.     >R GET-ORDER
  127.     DUP 0= search_order_underflow_throw AND THROW
  128.     NIP R> SWAP SET-ORDER ; \ /\/\ shd. == 0 THROW normally
  129.  
  130. INTERNALS-WORDLIST ALSO-WID
  131.  
  132. \ Create a named wordlist, then create a word of the same name emulating F83 VOCABULARY
  133. : VOCABULARY ( "ccc< >" --)
  134.     >IN @                           \ -- u, save pointer to input for recreating name
  135.     BL WORD COUNT NAMEWORDLIST      \ -- u wid
  136.     SWAP >IN !                      \ -- wid, restore input pointer for second create of same name
  137.     ABSTODATA DATATOCODE            \ -- adr, this is a code-relative address
  138.     CREATE ,                        \ -- create the named voc and save c-r-addr
  139.     DOES> ( -- wid)
  140.         @ CODETOABS SET-CONTEXT     \ -- at runtime, recalc wid from code-relative addr
  141. ;
  142.  
  143. \ ~~~~~~~~~~~~~~~~~~~~
  144. \ More on ENVIRONMENT?
  145. \ ~~~~~~~~~~~~~~~~~~~~
  146.  
  147. USEFUL HEX
  148.  
  149. \ Create a wordlist in which all the ENVIRONMENT? queries live.
  150. S" ENVIRONMENT" NAMEWORDLIST DROP
  151.  
  152. \ A redefinition of ENVIRONMENT?
  153. \ Maybe this should be moved back into the kernel
  154. : ENVIRONMENT? ( c-addr u -- false | i*x true)
  155.    ENVIRONMENT SEARCH-WORDLIST
  156.    IF EXECUTE TRUE ELSE FALSE THEN ;
  157.  
  158. \ The constants found by the queries.
  159. ENVIRONMENT ALSO-WID DEFINITIONS
  160.  
  161. \ These are all from dpANS-5 3.2.6
  162. FFFD CONSTANT /COUNTED-STRING
  163.   80 CONSTANT /HOLD
  164.   80 CONSTANT /PAD
  165.   08 CONSTANT ADDRESS-UNIT-BITS
  166. TRUE CONSTANT CORE
  167. FALSE CONSTANT CORE-EXT
  168. FALSE CONSTANT FLOORED
  169. FFFD CONSTANT MAX-CHAR
  170. 7FFFFFFFFFFFFFFF. DCONSTANT MAX-D
  171. 7FFFFFFF CONSTANT MAX-N
  172. FFFFFFFF CONSTANT MAX-U
  173. FFFFFFFFFFFFFFFF. DCONSTANT MAX-UD
  174. 1000 CONSTANT RETURN-STACK-CELLS \ may change
  175. 1000 CONSTANT STACK-CELLS   \ ditto
  176.  
  177. DECIMAL PREVIOUS DEFINITIONS
  178.  
  179. \ ~~~~~~~~~~~~~~
  180. \ End of utils.f
  181. \ ~~~~~~~~~~~~~~
  182.  
  183.